Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume10/xlisp21/part07

Text File | 1990-02-26 | 57.4 KB | 2,513 lines

Newsgroups: comp.sources.misc
organization: Cognos Inc., Ottawa, Canada
subject: v10i094: XLisP 2.1 sources 4a (1/2) / 5
From: [e-mail] (Gary Murphy)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 94
Submitted-by: [e-mail] (Gary Murphy)
Archive-name: xlisp21/part07

#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    xljump.c
#    xllist.c
#    xlmath.c
#    xlobj.c
#    xlpp.c
#    xlprin.c
# This archive created: Sun Feb 18 23:40:11 1990
# By:    Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xljump.c'" '(3889 characters)'
if test -f 'xljump.c'
then
    echo shar: over-writing existing file "'xljump.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xljump.c'
X/* xljump - execution context routines */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern CONTEXT *xlcontext,*xltarget;
Xextern LVAL xlvalue,xlenv,xlfenv,xldenv;
Xextern int xlmask;
X
X/* xlbegin - beginning of an execution context */
Xxlbegin(cptr,flags,expr)
X  CONTEXT *cptr; int flags; LVAL expr;
X{
X    cptr->c_flags = flags;
X    cptr->c_expr = expr;
X    cptr->c_xlstack = xlstack;
X    cptr->c_xlenv = xlenv;
X    cptr->c_xlfenv = xlfenv;
X    cptr->c_xldenv = xldenv;
X    cptr->c_xlcontext = xlcontext;
X    cptr->c_xlargv = xlargv;
X    cptr->c_xlargc = xlargc;
X    cptr->c_xlfp = xlfp;
X    cptr->c_xlsp = xlsp;
X    xlcontext = cptr;
X}
X
X/* xlend - end of an execution context */
Xxlend(cptr)
X  CONTEXT *cptr;
X{
X    xlcontext = cptr->c_xlcontext;
X}
X
X/* xlgo - go to a label */
Xxlgo(label)
X  LVAL label;
X{
X    CONTEXT *cptr;
X    LVAL *argv;
X    int argc;
X
X    /* find a tagbody context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & CF_GO) {
X        argc = cptr->c_xlargc;
X        argv = cptr->c_xlargv;
X        while (--argc >= 0)
X        if (*argv++ == label) {
X            cptr->c_xlargc = argc;
X            cptr->c_xlargv = argv;
X            xljump(cptr,CF_GO,NIL);
X        }
X    }
X    xlfail("no target for GO");
X}
X
X/* xlreturn - return from a block */
Xxlreturn(name,val)
X  LVAL name,val;
X{
X    CONTEXT *cptr;
X
X    /* find a block context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
X        xljump(cptr,CF_RETURN,val);
X    xlfail("no target for RETURN");
X}
X
X/* xlthrow - throw to a catch */
Xxlthrow(tag,val)
X  LVAL tag,val;
X{
X    CONTEXT *cptr;
X
X    /* find a catch context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
X        xljump(cptr,CF_THROW,val);
X    xlfail("no target for THROW");
X}
X
X/* xlsignal - signal an error */
Xxlsignal(emsg,arg)
X  char *emsg; LVAL arg;
X{
X    CONTEXT *cptr;
X
X    /* find an error catcher */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & CF_ERROR) {
X        if (cptr->c_expr && emsg)
X        xlerrprint("error",NULL,emsg,arg);
X        xljump(cptr,CF_ERROR,NIL);
X    }
X}
X
X/* xltoplevel - go back to the top level */
Xxltoplevel()
X{
X    stdputstr("[ back to top level ]\n");
X    findandjump(CF_TOPLEVEL,"no top level");
X}
X
X/* xlbrklevel - go back to the previous break level */
Xxlbrklevel()
X{
X    findandjump(CF_BRKLEVEL,"no previous break level");
X}
X
X/* xlcleanup - clean-up after an error */
Xxlcleanup()
X{
X    stdputstr("[ back to previous break level ]\n");
X    findandjump(CF_CLEANUP,"not in a break loop");
X}
X
X/* xlcontinue - continue from an error */
Xxlcontinue()
X{
X    findandjump(CF_CONTINUE,"not in a break loop");
X}
X
X/* xljump - jump to a saved execution context */
Xxljump(target,mask,val)
X  CONTEXT *target; int mask; LVAL val;
X{
X    /* unwind the execution stack */
X    for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
X
X    /* check for an UNWIND-PROTECT */
X    if ((xlcontext->c_flags & CF_UNWIND)) {
X        xltarget = target;
X        xlmask = mask;
X        break;
X    }
X
X    /* restore the state */
X    xlstack = xlcontext->c_xlstack;
X    xlenv = xlcontext->c_xlenv;
X    xlfenv = xlcontext->c_xlfenv;
X    xlunbind(xlcontext->c_xldenv);
X    xlargv = xlcontext->c_xlargv;
X    xlargc = xlcontext->c_xlargc;
X    xlfp = xlcontext->c_xlfp;
X    xlsp = xlcontext->c_xlsp;
X    xlvalue = val;
X
X    /* call the handler */
X    longjmp(xlcontext->c_jmpbuf,mask);
X}
X
X/* findandjump - find a target context frame and jump to it */
XLOCAL findandjump(mask,error)
X  int mask; char *error;
X{
X    CONTEXT *cptr;
X
X    /* find a block context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & mask)
X        xljump(cptr,mask,NIL);
X    xlabort(error);
X}
X
SHAR_EOF
if test 3889 -ne "`wc -c 'xljump.c'`"
then
    echo shar: error transmitting "'xljump.c'" '(should have been 3889 characters)'
fi
echo shar: extracting "'xllist.c'" '(18761 characters)'
if test -f 'xllist.c'
then
    echo shar: over-writing existing file "'xllist.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xllist.c'
X/* xllist.c - xlisp built-in list functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* forward declarations */
XFORWARD LVAL cxr();
XFORWARD LVAL nth(),assoc();
XFORWARD LVAL subst(),sublis(),map();
X
X/* xcar - take the car of a cons cell */
XLVAL xcar()
X{
X    LVAL list;
X    list = xlgalist();
X    xllastarg();
X    return (list ? car(list) : NIL);
X}
X
X/* xcdr - take the cdr of a cons cell */
XLVAL xcdr()
X{
X    LVAL list;
X    list = xlgalist();
X    xllastarg();
X    return (list ? cdr(list) : NIL);
X}
X
X/* cxxr functions */
XLVAL xcaar() { return (cxr("aa")); }
XLVAL xcadr() { return (cxr("da")); }
XLVAL xcdar() { return (cxr("ad")); }
XLVAL xcddr() { return (cxr("dd")); }
X
X/* cxxxr functions */
XLVAL xcaaar() { return (cxr("aaa")); }
XLVAL xcaadr() { return (cxr("daa")); }
XLVAL xcadar() { return (cxr("ada")); }
XLVAL xcaddr() { return (cxr("dda")); }
XLVAL xcdaar() { return (cxr("aad")); }
XLVAL xcdadr() { return (cxr("dad")); }
XLVAL xcddar() { return (cxr("add")); }
XLVAL xcdddr() { return (cxr("ddd")); }
X
X/* cxxxxr functions */
XLVAL xcaaaar() { return (cxr("aaaa")); }
XLVAL xcaaadr() { return (cxr("daaa")); }
XLVAL xcaadar() { return (cxr("adaa")); }
XLVAL xcaaddr() { return (cxr("ddaa")); }
XLVAL xcadaar() { return (cxr("aada")); }
XLVAL xcadadr() { return (cxr("dada")); }
XLVAL xcaddar() { return (cxr("adda")); }
XLVAL xcadddr() { return (cxr("ddda")); }
XLVAL xcdaaar() { return (cxr("aaad")); }
XLVAL xcdaadr() { return (cxr("daad")); }
XLVAL xcdadar() { return (cxr("adad")); }
XLVAL xcdaddr() { return (cxr("ddad")); }
XLVAL xcddaar() { return (cxr("aadd")); }
XLVAL xcddadr() { return (cxr("dadd")); }
XLVAL xcdddar() { return (cxr("addd")); }
XLVAL xcddddr() { return (cxr("dddd")); }
X
X/* cxr - common car/cdr routine */
XLOCAL LVAL cxr(adstr)
X  char *adstr;
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* perform the car/cdr operations */
X    while (*adstr && consp(list))
X    list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X    /* make sure the operation succeeded */
X    if (*adstr && list)
X    xlfail("bad argument");
X
X    /* return the result */
X    return (list);
X}
X
X/* xcons - construct a new list cell */
XLVAL xcons()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* construct a new list element */
X    return (cons(arg1,arg2));
X}
X
X/* xlist - built a list of the arguments */
XLVAL xlist()
X{
X    LVAL last,next,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* add each argument to the list */
X    for (val = NIL; moreargs(); ) {
X
X    /* append this argument to the end of the list */
X    next = consa(nextarg());
X    if (val) rplacd(last,next);
X    else val = next;
X    last = next;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the list */
X    return (val);
X}
X
X/* xappend - built-in function append */
XLVAL xappend()
X{
X    LVAL list,last,next,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* initialize */
X    val = NIL;
X
X    /* append each argument */
X    if (moreargs()) {
X    while (xlargc > 1) {
X
X        /* append each element of this list to the result list */
X        for (list = nextarg(); consp(list); list = cdr(list)) {
X        next = consa(car(list));
X        if (val) rplacd(last,next);
X        else val = next;
X        last = next;
X        }
X    }
X
X    /* handle the last argument */
X    if (val) rplacd(last,nextarg());
X    else val = nextarg();
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the list */
X    return (val);
X}
X
X/* xreverse - built-in function reverse */
XLVAL xreverse()
X{
X    LVAL list,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* get the list to reverse */
X    list = xlgalist();
X    xllastarg();
X
X    /* append each element to the head of the result list */
X    for (val = NIL; consp(list); list = cdr(list))
X    val = cons(car(list),val);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the list */
X    return (val);
X}
X
X/* xlast - return the last cons of a list */
XLVAL xlast()
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* find the last cons */
X    while (consp(list) && cdr(list))
X    list = cdr(list);
X
X    /* return the last element */
X    return (list);
X}
X
X/* xmember - built-in function 'member' */
XLVAL xmember()
X{
X    LVAL x,list,fcn,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to look for and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* look for the expression */
X    for (val = NIL; consp(list); list = cdr(list))
X    if (dotest2(x,car(list),fcn) == tresult) {
X        val = list;
X        break;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XLVAL xassoc()
X{
X    LVAL x,alist,fcn,pair,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to look for and the association list */
X    x = xlgetarg();
X    alist = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* look for the expression */
X    for (val = NIL; consp(alist); alist = cdr(alist))
X    if ((pair = car(alist)) && consp(pair))
X        if (dotest2(x,car(pair),fcn) == tresult) {
X        val = pair;
X        break;
X        }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return result */
X    return (val);
X}
X
X/* xsubst - substitute one expression for another */
XLVAL xsubst()
X{
X    LVAL to,from,expr,fcn,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the to value, the from value and the expression */
X    to = xlgetarg();
X    from = xlgetarg();
X    expr = xlgetarg();
X    xltest(&fcn,&tresult);
X
X    /* do the substitution */
X    val = subst(to,from,expr,fcn,tresult);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* subst - substitute one expression for another */
XLOCAL LVAL subst(to,from,expr,fcn,tresult)
X  LVAL to,from,expr,fcn; int tresult;
X{
X    LVAL carval,cdrval;
X
X    if (dotest2(expr,from,fcn) == tresult)
X    return (to);
X    else if (consp(expr)) {
X    xlsave1(carval);
X    carval = subst(to,from,car(expr),fcn,tresult);
X    cdrval = subst(to,from,cdr(expr),fcn,tresult);
X    xlpop();
X    return (cons(carval,cdrval));
X    }
X    else
X    return (expr);
X}
X
X/* xsublis - substitute using an association list */
XLVAL xsublis()
X{
X    LVAL alist,expr,fcn,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the assocation list and the expression */
X    alist = xlgalist();
X    expr = xlgetarg();
X    xltest(&fcn,&tresult);
X
X    /* do the substitution */
X    val = sublis(alist,expr,fcn,tresult);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* sublis - substitute using an association list */
XLOCAL LVAL sublis(alist,expr,fcn,tresult)
X  LVAL alist,expr,fcn; int tresult;
X{
X    LVAL carval,cdrval,pair;
X
X    if (pair = assoc(expr,alist,fcn,tresult))
X    return (cdr(pair));
X    else if (consp(expr)) {
X    xlsave1(carval);
X    carval = sublis(alist,car(expr),fcn,tresult);
X    cdrval = sublis(alist,cdr(expr),fcn,tresult);
X    xlpop();
X    return (cons(carval,cdrval));
X    }
X    else
X    return (expr);
X}
X
X/* assoc - find a pair in an association list */
XLOCAL LVAL assoc(expr,alist,fcn,tresult)
X  LVAL expr,alist,fcn; int tresult;
X{
X    LVAL pair;
X
X    for (; consp(alist); alist = cdr(alist))
X    if ((pair = car(alist)) && consp(pair))
X        if (dotest2(expr,car(pair),fcn) == tresult)
X        return (pair);
X    return (NIL);
X}
X
X/* xremove - built-in function 'remove' */
XLVAL xremove()
X{
X    LVAL x,list,fcn,val,last,next;
X    int tresult;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fcn);
X    xlsave(val);
X
X    /* get the expression to remove and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* remove matches */
X    for (; consp(list); list = cdr(list))
X
X    /* check to see if this element should be deleted */
X    if (dotest2(x,car(list),fcn) != tresult) {
X        next = consa(car(list));
X        if (val) rplacd(last,next);
X        else val = next;
X        last = next;
X    }
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the updated list */
X    return (val);
X}
X
X/* xremif - built-in function 'remove-if' */
XLVAL xremif()
X{
X    LVAL remif();
X    return (remif(TRUE));
X}
X
X/* xremifnot - built-in function 'remove-if-not' */
XLVAL xremifnot()
X{
X    LVAL remif();
X    return (remif(FALSE));
X}
X
X/* remif - common code for 'remove-if' and 'remove-if-not' */
XLOCAL LVAL remif(tresult)
X  int tresult;
X{
X    LVAL list,fcn,val,last,next;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fcn);
X    xlsave(val);
X
X    /* get the expression to remove and the list */
X    fcn = xlgetarg();
X    list = xlgalist();
X    xllastarg();
X
X    /* remove matches */
X    for (; consp(list); list = cdr(list))
X
X    /* check to see if this element should be deleted */
X    if (dotest1(car(list),fcn) != tresult) {
X        next = consa(car(list));
X        if (val) rplacd(last,next);
X        else val = next;
X        last = next;
X    }
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the updated list */
X    return (val);
X}
X
X/* dotest1 - call a test function with one argument */
Xint dotest1(arg,fun)
X  LVAL arg,fun;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)1));
X    pusharg(arg);
X    xlfp = newfp;
X
X    /* return the result of applying the test function */
X    return (xlapply(1) != NIL);
X
X}
X
X/* dotest2 - call a test function with two arguments */
Xint dotest2(arg1,arg2,fun)
X  LVAL arg1,arg2,fun;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(arg1);
X    pusharg(arg2);
X    xlfp = newfp;
X
X    /* return the result of applying the test function */
X    return (xlapply(2) != NIL);
X
X}
X
X/* xnth - return the nth element of a list */
XLVAL xnth()
X{
X    return (nth(TRUE));
X}
X
X/* xnthcdr - return the nth cdr of a list */
XLVAL xnthcdr()
X{
X    return (nth(FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL LVAL nth(carflag)
X  int carflag;
X{
X    LVAL list,num;
X    FIXTYPE n;
X
X    /* get n and the list */
X    num = xlgafixnum();
X    list = xlgacons();
X    xllastarg();
X
X    /* make sure the number isn't negative */
X    if ((n = getfixnum(num)) < 0)
X    xlfail("bad argument");
X
X    /* find the nth element */
X    while (consp(list) && --n >= 0)
X    list = cdr(list);
X
X    /* return the list beginning at the nth element */
X    return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xlength - return the length of a list or string */
XLVAL xlength()
X{
X    FIXTYPE n;
X    LVAL arg;
X
X    /* get the list or string */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* find the length of a list */
X    if (listp(arg))
X    for (n = 0; consp(arg); n++)
X        arg = cdr(arg);
X
X    /* find the length of a string */
X    else if (stringp(arg))
X    n = (FIXTYPE)getslength(arg)-1;
X
X    /* find the length of a vector */
X    else if (vectorp(arg))
X    n = (FIXTYPE)getsize(arg);
X
X    /* otherwise, bad argument type */
X    else
X    xlerror("bad argument type",arg);
X
X    /* return the length */
X    return (cvfixnum(n));
X}
X
X/* xmapc - built-in function 'mapc' */
XLVAL xmapc()
X{
X    return (map(TRUE,FALSE));
X}
X
X/* xmapcar - built-in function 'mapcar' */
XLVAL xmapcar()
X{
X    return (map(TRUE,TRUE));
X}
X
X/* xmapl - built-in function 'mapl' */
XLVAL xmapl()
X{
X    return (map(FALSE,FALSE));
X}
X
X/* xmaplist - built-in function 'maplist' */
XLVAL xmaplist()
X{
X    return (map(FALSE,TRUE));
X}
X
X/* map - internal mapping function */
XLOCAL LVAL map(carflag,valflag)
X  int carflag,valflag;
X{
X    LVAL *newfp,fun,lists,val,last,p,x,y;
X    int argc;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(fun);
X    xlsave(lists);
X    xlsave(val);
X
X    /* get the function to apply and the first list */
X    fun = xlgetarg();
X    lists = xlgalist();
X
X    /* initialize the result list */
X    val = (valflag ? NIL : lists);
X
X    /* build a list of argument lists */
X    for (lists = last = consa(lists); moreargs(); last = cdr(last))
X    rplacd(last,cons(xlgalist(),NIL));
X
X    /* loop through each of the argument lists */
X    for (;;) {
X
X    /* build an argument list from the sublists */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL);
X    argc = 0;
X    for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
X        pusharg(carflag ? car(y) : y);
X        rplaca(x,cdr(y));
X        ++argc;
X    }
X
X    /* quit if any of the lists were empty */
X    if (x) {
X        xlsp = newfp;
X        break;
X    }
X
X    /* apply the function to the arguments */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X    if (valflag) {
X        p = consa(xlapply(argc));
X        if (val) rplacd(last,p);
X        else val = p;
X        last = p;
X    }
X    else
X        xlapply(argc);
X    }
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xrplca - replace the car of a list node */
XLVAL xrplca()
X{
X    LVAL list,newcar;
X
X    /* get the list and the new car */
X    list = xlgacons();
X    newcar = xlgetarg();
X    xllastarg();
X
X    /* replace the car */
X    rplaca(list,newcar);
X
X    /* return the list node that was modified */
X    return (list);
X}
X
X/* xrplcd - replace the cdr of a list node */
XLVAL xrplcd()
X{
X    LVAL list,newcdr;
X
X    /* get the list and the new cdr */
X    list = xlgacons();
X    newcdr = xlgetarg();
X    xllastarg();
X
X    /* replace the cdr */
X    rplacd(list,newcdr);
X
X    /* return the list node that was modified */
X    return (list);
X}
X
X/* xnconc - destructively append lists */
XLVAL xnconc()
X{
X    LVAL next,last,val;
X
X    /* initialize */
X    val = NIL;
X
X    /* concatenate each argument */
X    if (moreargs()) {
X    while (xlargc > 1) {
X
X        /* ignore everything except lists */
X        if ((next = nextarg()) && consp(next)) {
X
X        /* concatenate this list to the result list */
X        if (val) rplacd(last,next);
X        else val = next;
X
X        /* find the end of the list */
X        while (consp(cdr(next)))
X            next = cdr(next);
X        last = next;
X        }
X    }
X
X    /* handle the last argument */
X    if (val) rplacd(last,nextarg());
X    else val = nextarg();
X    }
X
X    /* return the list */
X    return (val);
X}
X
X/* xdelete - built-in function 'delete' */
XLVAL xdelete()
X{
X    LVAL x,list,fcn,last,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to delete and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* delete leading matches */
X    while (consp(list)) {
X    if (dotest2(x,car(list),fcn) != tresult)
X        break;
X    list = cdr(list);
X    }
X    val = last = list;
X
X    /* delete embedded matches */
X    if (consp(list)) {
X
X    /* skip the first non-matching element */
X    list = cdr(list);
X
X    /* look for embedded matches */
X    while (consp(list)) {
X
X        /* check to see if this element should be deleted */
X        if (dotest2(x,car(list),fcn) == tresult)
X        rplacd(last,cdr(list));
X        else
X        last = list;
X
X        /* move to the next element */
X        list = cdr(list);
X     }
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the updated list */
X    return (val);
X}
X
X/* xdelif - built-in function 'delete-if' */
XLVAL xdelif()
X{
X    LVAL delif();
X    return (delif(TRUE));
X}
X
X/* xdelifnot - built-in function 'delete-if-not' */
XLVAL xdelifnot()
X{
X    LVAL delif();
X    return (delif(FALSE));
X}
X
X/* delif - common routine for 'delete-if' and 'delete-if-not' */
XLOCAL LVAL delif(tresult)
X  int tresult;
X{
X    LVAL list,fcn,last,val;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to delete and the list */
X    fcn = xlgetarg();
X    list = xlgalist();
X    xllastarg();
X
X    /* delete leading matches */
X    while (consp(list)) {
X    if (dotest1(car(list),fcn) != tresult)
X        break;
X    list = cdr(list);
X    }
X    val = last = list;
X
X    /* delete embedded matches */
X    if (consp(list)) {
X
X    /* skip the first non-matching element */
X    list = cdr(list);
X
X    /* look for embedded matches */
X    while (consp(list)) {
X
X        /* check to see if this element should be deleted */
X        if (dotest1(car(list),fcn) == tresult)
X        rplacd(last,cdr(list));
X        else
X        last = list;
X
X        /* move to the next element */
X        list = cdr(list);
X     }
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the updated list */
X    return (val);
X}
X
X/* xsort - built-in function 'sort' */
XLVAL xsort()
X{
X    LVAL sortlist();
X    LVAL list,fcn;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(list);
X    xlsave(fcn);
X
X    /* get the list to sort and the comparison function */
X    list = xlgalist();
X    fcn = xlgetarg();
X    xllastarg();
X
X    /* sort the list */
X    list = sortlist(list,fcn);
X
X    /* restore the stack and return the sorted list */
X    xlpopn(2);
X    return (list);
X}
X
X/*
X    This sorting algorithm is based on a Modula-2 sort written by
X    Richie Bielak and published in the February 1988 issue of
X    "Computer Language" magazine in a letter to the editor.
X*/
X
X/* sortlist - sort a list using quicksort */
XLOCAL LVAL sortlist(list,fcn)
X  LVAL list,fcn;
X{
X    LVAL gluelists();
X    LVAL smaller,pivot,larger;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(smaller);
X    xlsave(pivot);
X    xlsave(larger);
X
X    /* lists with zero or one element are already sorted */
X    if (consp(list) && consp(cdr(list))) {
X    pivot = list; list = cdr(list);
X    splitlist(pivot,list,&smaller,&larger,fcn);
X    smaller = sortlist(smaller,fcn);
X    larger = sortlist(larger,fcn);
X    list = gluelists(smaller,pivot,larger);
X    }
X
X    /* cleanup the stack and return the sorted list */
X    xlpopn(3);
X    return (list);
X}
X
X/* splitlist - split the list around the pivot */
XLOCAL splitlist(pivot,list,psmaller,plarger,fcn)
X  LVAL pivot,list,*psmaller,*plarger,fcn;
X{
X    LVAL next;
X
X    /* initialize the result lists */
X    *psmaller = *plarger = NIL;
X
X    /* split the list */
X    for (; consp(list); list = next) {
X    next = cdr(list);
X    if (dotest2(car(list),car(pivot),fcn)) {
X        rplacd(list,*psmaller);
X        *psmaller = list;
X    }
X    else {
X        rplacd(list,*plarger);
X        *plarger = list;
X    }
X    }
X}
X
X/* gluelists - glue the smaller and larger lists with the pivot */
XLOCAL LVAL gluelists(smaller,pivot,larger)
X  LVAL smaller,pivot,larger;
X{
X    LVAL last;
X
X    /* larger always goes after the pivot */
X    rplacd(pivot,larger);
X
X    /* if the smaller list is empty, we're done */
X    if (null(smaller))
X    return (pivot);
X
X    /* append the smaller to the front of the resulting list */
X    for (last = smaller; consp(cdr(last)); last = cdr(last))
X    ;
X    rplacd(last,pivot);
X    return (smaller);
X}
SHAR_EOF
if test 18761 -ne "`wc -c 'xllist.c'`"
then
    echo shar: error transmitting "'xllist.c'" '(should have been 18761 characters)'
fi
echo shar: extracting "'xlmath.c'" '(9993 characters)'
if test -f 'xlmath.c'
then
    echo shar: over-writing existing file "'xlmath.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlmath.c'
X/* xlmath - xlisp built-in arithmetic functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X#include <math.h>
X
X/* external variables */
Xextern LVAL true;
X
X/* forward declarations */
XFORWARD LVAL unary();
XFORWARD LVAL binary();
XFORWARD LVAL predicate();
XFORWARD LVAL compare();
X
X/* binary functions */
XLVAL xadd()    { return (binary('+')); } /* + */
XLVAL xsub()    { return (binary('-')); } /* - */
XLVAL xmul()    { return (binary('*')); } /* * */
XLVAL xdiv()    { return (binary('/')); } /* / */
XLVAL xrem()    { return (binary('%')); } /* rem */
XLVAL xmin()    { return (binary('m')); } /* min */
XLVAL xmax()    { return (binary('M')); } /* max */
XLVAL xexpt()   { return (binary('E')); } /* expt */
XLVAL xlogand() { return (binary('&')); } /* logand */
XLVAL xlogior() { return (binary('|')); } /* logior */
XLVAL xlogxor() { return (binary('^')); } /* logxor */
X
X/* xgcd - greatest common divisor */
XLVAL xgcd()
X{
X    FIXTYPE m,n,r;
X    LVAL arg;
X
X    if (!moreargs())            /* check for identity case */
X    return (cvfixnum((FIXTYPE)0));
X    arg = xlgafixnum();
X    n = getfixnum(arg);
X    if (n < (FIXTYPE)0) n = -n;        /* absolute value */
X    while (moreargs()) {
X    arg = xlgafixnum();
X    m = getfixnum(arg);
X    if (m < (FIXTYPE)0) m = -m;    /* absolute value */
X    for (;;) {            /* euclid's algorithm */
X        r = m % n;
X        if (r == (FIXTYPE)0)
X        break;
X        m = n;
X        n = r;
X    }
X    }
X    return (cvfixnum(n));
X}
X
X/* binary - handle binary operations */
XLOCAL LVAL binary(fcn)
X  int fcn;
X{
X    FIXTYPE ival,iarg;
X    FLOTYPE fval,farg;
X    LVAL arg;
X    int mode;
X
X    /* get the first argument */
X    arg = xlgetarg();
X
X    /* set the type of the first argument */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    mode = 'I';
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    mode = 'F';
X    }
X    else
X    xlerror("bad argument type",arg);
X
X    /* treat a single argument as a special case */
X    if (!moreargs()) {
X    switch (fcn) {
X    case '-':
X        switch (mode) {
X        case 'I':
X        ival = -ival;
X        break;
X        case 'F':
X        fval = -fval;
X        break;
X        }
X        break;
X    case '/':
X        switch (mode) {
X        case 'I':
X        checkizero(ival);
X        ival = 1 / ival;
X        break;
X        case 'F':
X        checkfzero(fval);
X        fval = 1.0 / fval;
X        break;
X        }
X    }
X    }
X
X    /* handle each remaining argument */
X    while (moreargs()) {
X
X    /* get the next argument */
X    arg = xlgetarg();
X
X    /* check its type */
X    if (fixp(arg)) {
X        switch (mode) {
X        case 'I':
X            iarg = getfixnum(arg);
X            break;
X        case 'F':
X            farg = (FLOTYPE)getfixnum(arg);
X        break;
X        }
X    }
X    else if (floatp(arg)) {
X        switch (mode) {
X        case 'I':
X            fval = (FLOTYPE)ival;
X        farg = getflonum(arg);
X        mode = 'F';
X        break;
X        case 'F':
X            farg = getflonum(arg);
X        break;
X        }
X    }
X    else
X        xlerror("bad argument type",arg);
X
X    /* accumulate the result value */
X    switch (mode) {
X    case 'I':
X        switch (fcn) {
X        case '+':    ival += iarg; break;
X        case '-':    ival -= iarg; break;
X        case '*':    ival *= iarg; break;
X        case '/':    checkizero(iarg); ival /= iarg; break;
X        case '%':    checkizero(iarg); ival %= iarg; break;
X        case 'M':    if (iarg > ival) ival = iarg; break;
X        case 'm':    if (iarg < ival) ival = iarg; break;
X        case '&':    ival &= iarg; break;
X        case '|':    ival |= iarg; break;
X        case '^':    ival ^= iarg; break;
X        default:    badiop();
X        }
X        break;
X    case 'F':
X        switch (fcn) {
X        case '+':    fval += farg; break;
X        case '-':    fval -= farg; break;
X        case '*':    fval *= farg; break;
X        case '/':    checkfzero(farg); fval /= farg; break;
X        case 'M':    if (farg > fval) fval = farg; break;
X        case 'm':    if (farg < fval) fval = farg; break;
X        case 'E':    fval = pow(fval,farg); break;
X        default:    badfop();
X        }
X            break;
X    }
X    }
X
X    /* return the result */
X    switch (mode) {
X    case 'I':    return (cvfixnum(ival));
X    case 'F':    return (cvflonum(fval));
X    }
X}
X
X/* checkizero - check for integer division by zero */
Xcheckizero(iarg)
X  FIXTYPE iarg;
X{
X    if (iarg == 0)
X    xlfail("division by zero");
X}
X
X/* checkfzero - check for floating point division by zero */
Xcheckfzero(farg)
X  FLOTYPE farg;
X{
X    if (farg == 0.0)
X    xlfail("division by zero");
X}
X
X/* checkfneg - check for square root of a negative number */
Xcheckfneg(farg)
X  FLOTYPE farg;
X{
X    if (farg < 0.0)
X    xlfail("square root of a negative number");
X}
X
X/* unary functions */
XLVAL xlognot() { return (unary('~')); } /* lognot */
XLVAL xabs()    { return (unary('A')); } /* abs */
XLVAL xadd1()   { return (unary('+')); } /* 1+ */
XLVAL xsub1()   { return (unary('-')); } /* 1- */
XLVAL xsin()    { return (unary('S')); } /* sin */
XLVAL xcos()    { return (unary('C')); } /* cos */
XLVAL xtan()    { return (unary('T')); } /* tan */
XLVAL xasin()   { return (unary('s')); } /* asin */
XLVAL xacos()   { return (unary('c')); } /* acos */
XLVAL xatan()   { return (unary('t')); } /* atan */
XLVAL xexp()    { return (unary('E')); } /* exp */
XLVAL xsqrt()   { return (unary('R')); } /* sqrt */
XLVAL xfix()    { return (unary('I')); } /* truncate */
XLVAL xfloat()  { return (unary('F')); } /* float */
XLVAL xrand()   { return (unary('?')); } /* random */
X
X/* unary - handle unary operations */
XLOCAL LVAL unary(fcn)
X  int fcn;
X{
X    FLOTYPE fval;
X    FIXTYPE ival;
X    LVAL arg;
X
X    /* get the argument */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* check its type */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    switch (fcn) {
X    case '~':    ival = ~ival; break;
X    case 'A':    ival = (ival < 0 ? -ival : ival); break;
X    case '+':    ival++; break;
X    case '-':    ival--; break;
X    case 'I':    break;
X    case 'F':    return (cvflonum((FLOTYPE)ival));
X    case '?':    ival = (FIXTYPE)osrand((int)ival); break;
X    default:    badiop();
X    }
X    return (cvfixnum(ival));
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    switch (fcn) {
X    case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
X    case '+':    fval += 1.0; break;
X    case '-':    fval -= 1.0; break;
X    case 'S':    fval = sin(fval); break;
X    case 'C':    fval = cos(fval); break;
X    case 'T':    fval = tan(fval); break;
X    case 's':    fval = asin(fval); break;
X    case 'c':    fval = acos(fval); break;
X    case 't':    fval = atan(fval); break;
X    case 'E':    fval = exp(fval); break;
X    case 'R':    checkfneg(fval); fval = sqrt(fval); break;
X    case 'I':    return (cvfixnum((FIXTYPE)fval));
X    case 'F':    break;
X    default:    badfop();
X    }
X    return (cvflonum(fval));
X    }
X    else
X    xlerror("bad argument type",arg);
X}
X
X/* unary predicates */
XLVAL xminusp() { return (predicate('-')); } /* minusp */
XLVAL xzerop()  { return (predicate('Z')); } /* zerop */
XLVAL xplusp()  { return (predicate('+')); } /* plusp */
XLVAL xevenp()  { return (predicate('E')); } /* evenp */
XLVAL xoddp()   { return (predicate('O')); } /* oddp */
X
X/* predicate - handle a predicate function */
XLOCAL LVAL predicate(fcn)
X  int fcn;
X{
X    FLOTYPE fval;
X    FIXTYPE ival;
X    LVAL arg;
X
X    /* get the argument */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* check the argument type */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    switch (fcn) {
X    case '-':    ival = (ival < 0); break;
X    case 'Z':    ival = (ival == 0); break;
X    case '+':    ival = (ival > 0); break;
X    case 'E':    ival = ((ival & 1) == 0); break;
X    case 'O':    ival = ((ival & 1) != 0); break;
X    default:    badiop();
X    }
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    switch (fcn) {
X    case '-':    ival = (fval < 0); break;
X    case 'Z':    ival = (fval == 0); break;
X    case '+':    ival = (fval > 0); break;
X    default:    badfop();
X    }
X    }
X    else
X    xlerror("bad argument type",arg);
X
X    /* return the result value */
X    return (ival ? true : NIL);
X}
X
X/* comparison functions */
XLVAL xlss() { return (compare('<')); } /* < */
XLVAL xleq() { return (compare('L')); } /* <= */
XLVAL xequ() { return (compare('=')); } /* = */
XLVAL xneq() { return (compare('#')); } /* /= */
XLVAL xgeq() { return (compare('G')); } /* >= */
XLVAL xgtr() { return (compare('>')); } /* > */
X
X/* compare - common compare function */
XLOCAL LVAL compare(fcn)
X  int fcn;
X{
X    FIXTYPE icmp,ival,iarg;
X    FLOTYPE fcmp,fval,farg;
X    LVAL arg;
X    int mode;
X
X    /* get the first argument */
X    arg = xlgetarg();
X
X    /* set the type of the first argument */
X    if (fixp(arg)) {
X    ival = getfixnum(arg);
X    mode = 'I';
X    }
X    else if (floatp(arg)) {
X    fval = getflonum(arg);
X    mode = 'F';
X    }
X    else
X    xlerror("bad argument type",arg);
X
X    /* handle each remaining argument */
X    for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
X
X    /* get the next argument */
X    arg = xlgetarg();
X
X    /* check its type */
X    if (fixp(arg)) {
X        switch (mode) {
X        case 'I':
X            iarg = getfixnum(arg);
X            break;
X        case 'F':
X            farg = (FLOTYPE)getfixnum(arg);
X        break;
X        }
X    }
X    else if (floatp(arg)) {
X        switch (mode) {
X        case 'I':
X            fval = (FLOTYPE)ival;
X        farg = getflonum(arg);
X        mode = 'F';
X        break;
X        case 'F':
X            farg = getflonum(arg);
X        break;
X        }
X    }
X    else
X        xlerror("bad argument type",arg);
X
X    /* compute result of the compare */
X    switch (mode) {
X    case 'I':
X        icmp = ival - iarg;
X        switch (fcn) {
X        case '<':    icmp = (icmp < 0); break;
X        case 'L':    icmp = (icmp <= 0); break;
X        case '=':    icmp = (icmp == 0); break;
X        case '#':    icmp = (icmp != 0); break;
X        case 'G':    icmp = (icmp >= 0); break;
X        case '>':    icmp = (icmp > 0); break;
X        }
X        break;
X    case 'F':
X        fcmp = fval - farg;
X        switch (fcn) {
X        case '<':    icmp = (fcmp < 0.0); break;
X        case 'L':    icmp = (fcmp <= 0.0); break;
X        case '=':    icmp = (fcmp == 0.0); break;
X        case '#':    icmp = (fcmp != 0.0); break;
X        case 'G':    icmp = (fcmp >= 0.0); break;
X        case '>':    icmp = (fcmp > 0.0); break;
X        }
X        break;
X    }
X    }
X
X    /* return the result */
X    return (icmp ? true : NIL);
X}
X
X/* badiop - bad integer operation */
XLOCAL badiop()
X{
X    xlfail("bad integer operation");
X}
X
X/* badfop - bad floating point operation */
XLOCAL badfop()
X{
X    xlfail("bad floating point operation");
X}
SHAR_EOF
if test 9993 -ne "`wc -c 'xlmath.c'`"
then
    echo shar: error transmitting "'xlmath.c'" '(should have been 9993 characters)'
fi
echo shar: extracting "'xlobj.c'" '(11545 characters)'
if test -f 'xlobj.c'
then
    echo shar: over-writing existing file "'xlobj.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlobj.c'
X/* xlobj - xlisp object functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xlvalue;
Xextern LVAL s_stdout,s_lambda;
X
X/* local variables */
Xstatic LVAL s_self,k_new,k_isnew;
Xstatic LVAL class,object;
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES    0    /* list of messages */
X#define IVARS        1    /* list of instance variable names */
X#define CVARS        2    /* list of class variable names */
X#define CVALS        3    /* list of class variable values */
X#define SUPERCLASS    4    /* pointer to the superclass */
X#define IVARCNT        5    /* number of class instance variables */
X#define IVARTOTAL    6    /* total number of instance variables */
X
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE    7
X
X/* forward declarations */
XFORWARD LVAL entermsg();
XFORWARD LVAL sendmsg();
XFORWARD LVAL evmethod();
X
X/* xsend - send a message to an object */
XLVAL xsend()
X{
X    LVAL obj;
X    obj = xlgaobject();
X    return (sendmsg(obj,getclass(obj),xlgasymbol()));
X}
X
X/* xsendsuper - send a message to the superclass of an object */
XLVAL xsendsuper()
X{
X    LVAL env,p;
X    for (env = xlenv; env; env = cdr(env))
X    if ((p = car(env)) && objectp(car(p)))
X        return (sendmsg(car(p),
X                getivar(cdr(p),SUPERCLASS),
X                xlgasymbol()));
X    xlfail("not in a method");
X}
X
X/* xlclass - define a class */
XLVAL xlclass(name,vcnt)
X  char *name; int vcnt;
X{
X    LVAL sym,cls;
X
X    /* create the class */
X    sym = xlenter(name);
X    cls = newobject(class,CLASSSIZE);
X    setvalue(sym,cls);
X
X    /* set the instance variable counts */
X    setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
X    setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
X
X    /* set the superclass to 'Object' */
X    setivar(cls,SUPERCLASS,object);
X
X    /* return the new class */
X    return (cls);
X}
X
X/* xladdivar - enter an instance variable */
Xxladdivar(cls,var)
X  LVAL cls; char *var;
X{
X    setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
X}
X
X/* xladdmsg - add a message to a class */
Xxladdmsg(cls,msg,offset)
X  LVAL cls; char *msg; int offset;
X{
X    extern FUNDEF funtab[];
X    LVAL mptr;
X
X    /* enter the message selector */
X    mptr = entermsg(cls,xlenter(msg));
X
X    /* store the method for this message */
X    rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
X}
X
X/* xlobgetvalue - get the value of an instance variable */
Xint xlobgetvalue(pair,sym,pval)
X  LVAL pair,sym,*pval;
X{
X    LVAL cls,names;
X    int ivtotal,n;
X
X    /* find the instance or class variable */
X    for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X
X    /* check the instance variables */
X    names = getivar(cls,IVARS);
X    ivtotal = getivcnt(cls,IVARTOTAL);
X    for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X        if (car(names) == sym) {
X        *pval = getivar(car(pair),n);
X        return (TRUE);
X        }
X        names = cdr(names);
X    }
X
X    /* check the class variables */
X    names = getivar(cls,CVARS);
X    for (n = 0; consp(names); ++n) {
X        if (car(names) == sym) {
X        *pval = getelement(getivar(cls,CVALS),n);
X        return (TRUE);
X        }
X        names = cdr(names);
X    }
X    }
X
X    /* variable not found */
X    return (FALSE);
X}
X
X/* xlobsetvalue - set the value of an instance variable */
Xint xlobsetvalue(pair,sym,val)
X  LVAL pair,sym,val;
X{
X    LVAL cls,names;
X    int ivtotal,n;
X
X    /* find the instance or class variable */
X    for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
X
X    /* check the instance variables */
X    names = getivar(cls,IVARS);
X    ivtotal = getivcnt(cls,IVARTOTAL);
X    for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X        if (car(names) == sym) {
X        setivar(car(pair),n,val);
X        return (TRUE);
X        }
X        names = cdr(names);
X    }
X
X    /* check the class variables */
X    names = getivar(cls,CVARS);
X    for (n = 0; consp(names); ++n) {
X        if (car(names) == sym) {
X        setelement(getivar(cls,CVALS),n,val);
X        return (TRUE);
X        }
X        names = cdr(names);
X    }
X    }
X
X    /* variable not found */
X    return (FALSE);
X}
X
X/* obisnew - default 'isnew' method */
XLVAL obisnew()
X{
X    LVAL self;
X    self = xlgaobject();
X    xllastarg();
X    return (self);
X}
X
X/* obclass - get the class of an object */
XLVAL obclass()
X{
X    LVAL self;
X    self = xlgaobject();
X    xllastarg();
X    return (getclass(self));
X}
X
X/* obshow - show the instance variables of an object */
XLVAL obshow()
X{
X    LVAL self,fptr,cls,names;
X    int ivtotal,n;
X
X    /* get self and the file pointer */
X    self = xlgaobject();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* get the object's class */
X    cls = getclass(self);
X
X    /* print the object and class */
X    xlputstr(fptr,"Object is ");
X    xlprint(fptr,self,TRUE);
X    xlputstr(fptr,", Class is ");
X    xlprint(fptr,cls,TRUE);
X    xlterpri(fptr);
X
X    /* print the object's instance variables */
X    for (; cls; cls = getivar(cls,SUPERCLASS)) {
X    names = getivar(cls,IVARS);
X    ivtotal = getivcnt(cls,IVARTOTAL);
X    for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
X        xlputstr(fptr,"  ");
X        xlprint(fptr,car(names),TRUE);
X        xlputstr(fptr," = ");
X        xlprint(fptr,getivar(self,n),TRUE);
X        xlterpri(fptr);
X        names = cdr(names);
X    }
X    }
X
X    /* return the object */
X    return (self);
X}
X
X/* clnew - create a new object instance */
XLVAL clnew()
X{
X    LVAL self;
X    self = xlgaobject();
X    return (newobject(self,getivcnt(self,IVARTOTAL)));
X}
X
X/* clisnew - initialize a new class */
XLVAL clisnew()
X{
X    LVAL self,ivars,cvars,super;
X    int n;
X
X    /* get self, the ivars, cvars and superclass */
X    self = xlgaobject();
X    ivars = xlgalist();
X    cvars = (moreargs() ? xlgalist() : NIL);
X    super = (moreargs() ? xlgaobject() : object);
X    xllastarg();
X
X    /* store the instance and class variable lists and the superclass */
X    setivar(self,IVARS,ivars);
X    setivar(self,CVARS,cvars);
X    setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
X    setivar(self,SUPERCLASS,super);
X
X    /* compute the instance variable count */
X    n = listlength(ivars);
X    setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
X    n += getivcnt(super,IVARTOTAL);
X    setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
X
X    /* return the new class object */
X    return (self);
X}
X
X/* clanswer - define a method for answering a message */
XLVAL clanswer()
X{
X    LVAL self,msg,fargs,code,mptr;
X
X    /* message symbol, formal argument list and code */
X    self = xlgaobject();
X    msg = xlgasymbol();
X    fargs = xlgalist();
X    code = xlgalist();
X    xllastarg();
X
X    /* make a new message list entry */
X    mptr = entermsg(self,msg);
X
X    /* setup the message node */
X    xlprot1(fargs);
X    fargs = cons(s_self,fargs); /* add 'self' as the first argument */
X    rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL));
X    xlpop();
X
X    /* return the object */
X    return (self);
X}
X
X/* entermsg - add a message to a class */
XLOCAL LVAL entermsg(cls,msg)
X  LVAL cls,msg;
X{
X    LVAL lptr,mptr;
X
X    /* lookup the message */
X    for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
X    if (car(mptr = car(lptr)) == msg)
X        return (mptr);
X
X    /* allocate a new message entry if one wasn't found */
X    xlsave1(mptr);
X    mptr = consa(msg);
X    setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
X    xlpop();
X
X    /* return the symbol node */
X    return (mptr);
X}
X
X/* sendmsg - send a message to an object */
XLOCAL LVAL sendmsg(obj,cls,sym)
X  LVAL obj,cls,sym;
X{
X    LVAL msg,msgcls,method,val,p;
X
X    /* look for the message in the class or superclasses */
X    for (msgcls = cls; msgcls; ) {
X
X    /* lookup the message in this class */
X    for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
X        if ((msg = car(p)) && car(msg) == sym)
X        goto send_message;
X
X    /* look in class's superclass */
X    msgcls = getivar(msgcls,SUPERCLASS);
X    }
X
X    /* message not found */
X    xlerror("no method for this message",sym);
X
Xsend_message:
X
X    /* insert the value for 'self' (overwrites message selector) */
X    *--xlargv = obj;
X    ++xlargc;
X
X    /* invoke the method */
X    if ((method = cdr(msg)) == NULL)
X    xlerror("bad method",method);
X    switch (ntype(method)) {
X    case SUBR:
X    val = (*getsubr(method))();
X    break;
X    case CLOSURE:
X    if (gettype(method) != s_lambda)
X        xlerror("bad method",method);
X    val = evmethod(obj,msgcls,method);
X    break;
X    default:
X    xlerror("bad method",method);
X    }
X
X    /* after creating an object, send it the ":isnew" message */
X    if (car(msg) == k_new && val) {
X    xlprot1(val);
X    sendmsg(val,getclass(val),k_isnew);
X    xlpop();
X    }
X
X    /* return the result value */
X    return (val);
X}
X
X/* evmethod - evaluate a method */
XLOCAL LVAL evmethod(obj,msgcls,method)
X  LVAL obj,msgcls,method;
X{
X    LVAL oldenv,oldfenv,cptr,name,val;
X    CONTEXT cntxt;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X    xlsave(cptr);
X
X    /* create an 'object' stack entry and a new environment frame */
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = cons(cons(obj,msgcls),getenv(method));
X    xlenv = xlframe(xlenv);
X    xlfenv = getfenv(method);
X
X    /* bind the formal parameters */
X    xlabind(method,xlargc,xlargv);
X
X    /* setup the implicit block */
X    if (name = getname(method))
X    xlbegin(&cntxt,CF_RETURN,name);
X
X    /* execute the block */
X    if (name && setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
X        val = xleval(car(cptr));
X
X    /* finish the block context */
X    if (name)
X    xlend(&cntxt);
X
X    /* restore the environment */
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the result value */
X    return (val);
X}
X
X/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X  LVAL cls; int ivar;
X{
X    LVAL cnt;
X    if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
X    xlfail("bad value for instance variable count");
X    return ((int)getfixnum(cnt));
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X  LVAL list;
X{
X    int len;
X    for (len = 0; consp(list); len++)
X    list = cdr(list);
X    return (len);
X}
X
X/* obsymbols - initialize symbols */
Xobsymbols()
X{
X    /* enter the object related symbols */
X    s_self  = xlenter("SELF");
X    k_new   = xlenter(":NEW");
X    k_isnew = xlenter(":ISNEW");
X
X    /* get the Object and Class symbol values */
X    object = getvalue(xlenter("OBJECT"));
X    class  = getvalue(xlenter("CLASS"));
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X    /* create the 'Class' object */
X    class = xlclass("CLASS",CLASSSIZE);
X    setelement(class,0,class);
X
X    /* create the 'Object' object */
X    object = xlclass("OBJECT",0);
X
X    /* finish initializing 'class' */
X    setivar(class,SUPERCLASS,object);
X    xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
X    xladdivar(class,"IVARCNT");        /* ivar number 5 */
X    xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
X    xladdivar(class,"CVALS");        /* ivar number 3 */
X    xladdivar(class,"CVARS");        /* ivar number 2 */
X    xladdivar(class,"IVARS");        /* ivar number 1 */
X    xladdivar(class,"MESSAGES");    /* ivar number 0 */
X    xladdmsg(class,":NEW",FT_CLNEW);
X    xladdmsg(class,":ISNEW",FT_CLISNEW);
X    xladdmsg(class,":ANSWER",FT_CLANSWER);
X
X    /* finish initializing 'object' */
X    setivar(object,SUPERCLASS,NIL);
X    xladdmsg(object,":ISNEW",FT_OBISNEW);
X    xladdmsg(object,":CLASS",FT_OBCLASS);
X    xladdmsg(object,":SHOW",FT_OBSHOW);
X}
X
SHAR_EOF
if test 11545 -ne "`wc -c 'xlobj.c'`"
then
    echo shar: error transmitting "'xlobj.c'" '(should have been 11545 characters)'
fi
echo shar: extracting "'xlpp.c'" '(2111 characters)'
if test -f 'xlpp.c'
then
    echo shar: over-writing existing file "'xlpp.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlpp.c'
X/* xlpp.c - xlisp pretty printer */
X/*    Copyright (c) 1985, by David Betz
X    All Rights Reserved            */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL s_stdout;
Xextern int xlfsize;
X
X/* local variables */
Xstatic int pplevel,ppmargin,ppmaxlen;
Xstatic LVAL ppfile;
X
X/* xpp - pretty-print an expression */
XLVAL xpp()
X{
X    LVAL expr;
X
X    /* get expression to print and file pointer */
X    expr = xlgetarg();
X    ppfile = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* pretty print the expression */
X    pplevel = ppmargin = 0; ppmaxlen = 40;
X    pp(expr); ppterpri(ppfile);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* pp - pretty print an expression */
XLOCAL pp(expr)
X  LVAL expr;
X{
X    if (consp(expr))
X    pplist(expr);
X    else
X    ppexpr(expr);
X}
X
X/* pplist - pretty print a list */
XLOCAL pplist(expr)
X  LVAL expr;
X{
X    int n;
X
X    /* if the expression will fit on one line, print it on one */
X    if ((n = flatsize(expr)) < ppmaxlen) {
X    xlprint(ppfile,expr,TRUE);
X    pplevel += n;
X    }
X
X    /* otherwise print it on several lines */
X    else {
X    n = ppmargin;
X    ppputc('(');
X    if (atom(car(expr))) {
X        ppexpr(car(expr));
X        ppputc(' ');
X        ppmargin = pplevel;
X        expr = cdr(expr);
X    }
X    else
X        ppmargin = pplevel;
X    for (; consp(expr); expr = cdr(expr)) {
X        pp(car(expr));
X        if (consp(cdr(expr)))
X        ppterpri();
X    }
X    if (expr != NIL) {
X        ppputc(' '); ppputc('.'); ppputc(' ');
X        ppexpr(expr);
X    }
X    ppputc(')');
X    ppmargin = n;
X    }
X}
X
X/* ppexpr - print an expression and update the indent level */
XLOCAL ppexpr(expr)
X  LVAL expr;
X{
X    xlprint(ppfile,expr,TRUE);
X    pplevel += flatsize(expr);
X}
X
X/* ppputc - output a character and update the indent level */
XLOCAL ppputc(ch)
X  int ch;
X{
X    xlputc(ppfile,ch);
X    pplevel++;
X}
X
X/* ppterpri - terminate the print line and indent */
XLOCAL ppterpri()
X{
X    xlterpri(ppfile);
X    for (pplevel = 0; pplevel < ppmargin; pplevel++)
X    xlputc(ppfile,' ');
X}
X
X/* flatsize - compute the flat size of an expression */
XLOCAL int flatsize(expr)
X  LVAL expr;
X{
X    xlfsize = 0;
X    xlprint(NIL,expr,TRUE);
X    return (xlfsize);
X}
SHAR_EOF
if test 2111 -ne "`wc -c 'xlpp.c'`"
then
    echo shar: error transmitting "'xlpp.c'" '(should have been 2111 characters)'
fi
echo shar: extracting "'xlprin.c'" '(7244 characters)'
if test -f 'xlprin.c'
then
    echo shar: over-writing existing file "'xlprin.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlprin.c'
X/* xlprint - xlisp print routine */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL tentry();
Xextern LVAL s_printcase,k_downcase,k_const,k_nmacro;
Xextern LVAL s_ifmt,s_ffmt;
Xextern FUNDEF funtab[];
Xextern char buf[];
X
X/* xlprint - print an xlisp value */
Xxlprint(fptr,vptr,flag)
X  LVAL fptr,vptr; int flag;
X{
X    LVAL nptr,next;
X    int n,i;
X
X    /* print nil */
X    if (vptr == NIL) {
X    putsymbol(fptr,"NIL",flag);
X    return;
X    }
X
X    /* check value type */
X    switch (ntype(vptr)) {
X    case SUBR:
X        putsubr(fptr,"Subr",vptr);
X        break;
X    case FSUBR:
X        putsubr(fptr,"FSubr",vptr);
X        break;
X    case CONS:
X        xlputc(fptr,'(');
X        for (nptr = vptr; nptr != NIL; nptr = next) {
X            xlprint(fptr,car(nptr),flag);
X        if (next = cdr(nptr))
X            if (consp(next))
X            xlputc(fptr,' ');
X            else {
X            xlputstr(fptr," . ");
X            xlprint(fptr,next,flag);
X            break;
X            }
X        }
X        xlputc(fptr,')');
X        break;
X    case SYMBOL:
X        putsymbol(fptr,getstring(getpname(vptr)),flag);
X        break;
X    case FIXNUM:
X        putfixnum(fptr,getfixnum(vptr));
X        break;
X    case FLONUM:
X        putflonum(fptr,getflonum(vptr));
X        break;
X    case CHAR:
X        putchcode(fptr,getchcode(vptr),flag);
X        break;
X    case STRING:
X        if (flag)
X        putqstring(fptr,vptr);
X        else
X        putstring(fptr,vptr);
X        break;
X    case STREAM:
X        putatm(fptr,"File-Stream",vptr);
X        break;
X    case USTREAM:
X        putatm(fptr,"Unnamed-Stream",vptr);
X        break;
X    case OBJECT:
X        putatm(fptr,"Object",vptr);
X        break;
X    case VECTOR:
X        xlputc(fptr,'#'); xlputc(fptr,'(');
X        for (i = 0, n = getsize(vptr) - 1; i <= n; ++i) {
X        xlprint(fptr,getelement(vptr,i),flag);
X        if (i != n) xlputc(fptr,' ');
X        }
X        xlputc(fptr,')');
X        break;
X    case STRUCT:
X        xlprstruct(fptr,vptr,flag);
X        break;
X    case CLOSURE:
X        putclosure(fptr,vptr);
X        break;
X    case FREE:
X        putatm(fptr,"Free",vptr);
X        break;
X    default:
X        putatm(fptr,"Foo",vptr);
X        break;
X    }
X}
X
X/* xlterpri - terminate the current print line */
Xxlterpri(fptr)
X  LVAL fptr;
X{
X    xlputc(fptr,'\n');
X}
X
X/* xlputstr - output a string */
Xxlputstr(fptr,str)
X  LVAL fptr; char *str;
X{
X    while (*str)
X    xlputc(fptr,*str++);
X}
X
X/* putsymbol - output a symbol */
XLOCAL putsymbol(fptr,str,escflag)
X  LVAL fptr; char *str; int escflag;
X{
X    int downcase,ch;
X    LVAL type;
X    char *p;
X
X    /* check for printing without escapes */
X    if (!escflag) {
X    xlputstr(fptr,str);
X    return;
X    }
X
X    /* check to see if symbol needs escape characters */
X    if (tentry(*str) == k_const) {
X    for (p = str; *p; ++p)
X        if (islower(*p)
X        ||  ((type = tentry(*p)) != k_const
X          && (!consp(type) || car(type) != k_nmacro))) {
X        xlputc(fptr,'|');
X        while (*str) {
X            if (*str == '\\' || *str == '|')
X            xlputc(fptr,'\\');
X            xlputc(fptr,*str++);
X        }
X        xlputc(fptr,'|');
X        return;
X        }
X    }
X
X    /* get the case translation flag */
X    downcase = (getvalue(s_printcase) == k_downcase);
X
X    /* check for the first character being '#' */
X    if (*str == '#' || *str == '.' || isnumber(str,NULL))
X    xlputc(fptr,'\\');
X
X    /* output each character */
X    while ((ch = *str++) != '\0') {
X    /* don't escape colon until we add support for packages */
X    if (ch == '\\' || ch == '|' /* || ch == ':' */)
X        xlputc(fptr,'\\');
X    xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch));
X    }
X}
X
X/* putstring - output a string */
XLOCAL putstring(fptr,str)
X  LVAL fptr,str;
X{
X    unsigned char *p;
X    int ch;
X
X    /* output each character */
X    for (p = getstring(str); (ch = *p) != '\0'; ++p)
X    xlputc(fptr,ch);
X}
X
X/* putqstring - output a quoted string */
XLOCAL putqstring(fptr,str)
X  LVAL fptr,str;
X{
X    unsigned char *p;
X    int ch;
X
X    /* get the string pointer */
X    p = getstring(str);
X
X    /* output the initial quote */
X    xlputc(fptr,'"');
X
X    /* output each character in the string */
X    for (p = getstring(str); (ch = *p) != '\0'; ++p)
X
X    /* check for a control character */
X    if (ch < 040 || ch == '\\' || ch > 0176) {
X        xlputc(fptr,'\\');
X        switch (ch) {
X        case '\011':
X            xlputc(fptr,'t');
X            break;
X        case '\012':
X            xlputc(fptr,'n');
X            break;
X        case '\014':
X            xlputc(fptr,'f');
X            break;
X        case '\015':
X            xlputc(fptr,'r');
X            break;
X        case '\\':
X            xlputc(fptr,'\\');
X            break;
X        default:
X            putoct(fptr,ch);
X            break;
X        }
X    }
X
X    /* output a normal character */
X    else
X        xlputc(fptr,ch);
X
X    /* output the terminating quote */
X    xlputc(fptr,'"');
X}
X
X/* putatm - output an atom */
XLOCAL putatm(fptr,tag,val)
X  LVAL fptr; char *tag; LVAL val;
X{
X    sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
X    sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X    xlputc(fptr,'>');
X}
X
X/* putsubr - output a subr/fsubr */
XLOCAL putsubr(fptr,tag,val)
X  LVAL fptr; char *tag; LVAL val;
X{
X    sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name);
X    xlputstr(fptr,buf);
X    sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X    xlputc(fptr,'>');
X}
X
X/* putclosure - output a closure */
XLOCAL putclosure(fptr,val)
X  LVAL fptr,val;
X{
X    LVAL name;
X    if (name = getname(val))
X    sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
X    else
X    strcpy(buf,"#<Closure: #");
X    xlputstr(fptr,buf);
X    sprintf(buf,AFMT,val); xlputstr(fptr,buf);
X    xlputc(fptr,'>');
X/*
X    xlputstr(fptr,"\nName:   "); xlprint(fptr,getname(val),TRUE);
X    xlputstr(fptr,"\nType:   "); xlprint(fptr,gettype(val),TRUE);
X    xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
X    xlputstr(fptr,"\nArgs:   "); xlprint(fptr,getargs(val),TRUE);
X    xlputstr(fptr,"\nOargs:  "); xlprint(fptr,getoargs(val),TRUE);
X    xlputstr(fptr,"\nRest:   "); xlprint(fptr,getrest(val),TRUE);
X    xlputstr(fptr,"\nKargs:  "); xlprint(fptr,getkargs(val),TRUE);
X    xlputstr(fptr,"\nAargs:  "); xlprint(fptr,getaargs(val),TRUE);
X    xlputstr(fptr,"\nBody:   "); xlprint(fptr,getbody(val),TRUE);
X    xlputstr(fptr,"\nEnv:    "); xlprint(fptr,getenv(val),TRUE);
X    xlputstr(fptr,"\nFenv:   "); xlprint(fptr,getfenv(val),TRUE);
X*/
X}
X
X/* putfixnum - output a fixnum */
XLOCAL putfixnum(fptr,n)
X  LVAL fptr; FIXTYPE n;
X{
X    unsigned char *fmt;
X    LVAL val;
X    fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
X                            : (unsigned char *)IFMT);
X    sprintf(buf,fmt,n);
X    xlputstr(fptr,buf);
X}
X
X/* putflonum - output a flonum */
XLOCAL putflonum(fptr,n)
X  LVAL fptr; FLOTYPE n;
X{
X    unsigned char *fmt;
X    LVAL val;
X    fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
X                            : (unsigned char *)"%g");
X    sprintf(buf,fmt,n);
X    xlputstr(fptr,buf);
X}
X
X/* putchcode - output a character */
XLOCAL putchcode(fptr,ch,escflag)
X  LVAL fptr; int ch,escflag;
X{
X    if (escflag) {
X    switch (ch) {
X    case '\n':
X        xlputstr(fptr,"#\\Newline");
X        break;
X    case ' ':
X        xlputstr(fptr,"#\\Space");
X        break;
X    default:
X        sprintf(buf,"#\\%c",ch);
X        xlputstr(fptr,buf);
X        break;
X    }
X    }
X    else
X    xlputc(fptr,ch);
X}
X
X/* putoct - output an octal byte value */
XLOCAL putoct(fptr,n)
X  LVAL fptr; int n;
X{
X    sprintf(buf,"%03o",n);
X    xlputstr(fptr,buf);
X}
SHAR_EOF
if test 7244 -ne "`wc -c 'xlprin.c'`"
then
    echo shar: error transmitting "'xlprin.c'" '(should have been 7244 characters)'
fi
#    End of shell archive
exit 0
--
Gary Murphy                   uunet!mitel!sce!cognos!garym
                              ([e-mail])
[phone] x5537          Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc